C*** SUBROUTINES FROM MS.F4
C*** DISAPR, INSCOR, ZOOM, ESPOS, EDCEN, CENTXT, CONTXT, MORCEN, GETMS

	INTEGER FUNCTION DISAPR(DP)
	DIMENSION DP(0/7)
	COMMON R2,JA,CENTR,J2,RJQ(20)
	DISAPR=0
	IF(R2.GT.7)GO TO 620
C  GO BACK AND RESET ALL IF STF NUM >7
	K=R2
	JA=0
	IF(K.GE.0)GO TO 610
C TYPE DP -1  FOR ALL INVISIBLE
	DO 611 K=0,7
611	DP(K)=-1
	RETURN
610	IF(K.EQ.8)K=0
	DP(K)=-DP(K)
	JA=JA+1
	K=RJQ(JA)
	IF(K.EQ.0)RETURN
C  JUMP OUT IF RJQ(JA)=0 OR 99
	IF(K.EQ.99)GO TO 1320
C*** 3/74  END WITH '99' TO MAKE DP RIGHT NOW!
	GO TO 610
620	DO 630 K=0,7
630	DP(K)=1
1320	DISAPR=-1
C  TO GET BACK OTHERS - 'DPY N' AGAIN WILL DO.
	END

	FUNCTION INSCOR(SCORE)
	IMPLICIT INTEGER(A-Q,S-Z)
	COMMON  /LIMIT/LIMIT,ITEM,L,I,IX,ITEMX,ILIM
	COMMON /DL/X22,SAVER,NAME,EXT,IOLD /RRJJ/RJJ2,RJJ(20),JJA
	1 /XRN/RN(3000) /DPY/ST(4000),MEDIT,IGO 
	1 /PTR/PWDS(350) /CHK/ICHK,ITCHK,JIT,SPD,IDPY,M
	3 /SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	2 /RMOD/RMODE2,RSET4,IBEAM
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	EQUIVALENCE (ST2,ST(2))
	INSCOR=0
	IF(REND.LT.0)GO TO 1050
C REND=0 GO,  -1=NORMAL END,  1=ABORTED.
	CALL SCMSS
	IOLD=0
	IF(REND.EQ.1)GO TO 1050
	IF(REND.NE.99)GO TO 1020
	I=ICHK
	ITEM=ITCHK
	ST2=IDPY
	CALL ACCPOG(1)
        CALL DPYDO(1)
	GO TO 1050
1020	ITEM=JIT
	J=M
1030	ITEM=ITEM+1
	PWDS(ITEM)=J
	J=J+RN(J)+3
	IF(J.LT.I)GO TO 1030
	IF(IBEAM)GO TO 1040
	R2=RSTF
	JA=-1
	CALL HOMX
C GO ADJUST STEM LENGTHS
1040	ITEM=JIT
	ST2=SPD
	RETURN
1050	SCORE=-1
	CALL SHRINK(JIT)
C  GETS RID OF ZEROS AT END OF NOTE PARAM LIST.
	IGO=-1
	JA=16
C  FOR TRAP AT 'EDIT'
	INSCOR=-1
	END

	SUBROUTINE ZOOM
C** CALLS SCL, ZCRSOR
	IMPLICIT INTEGER(A-Q,S-Z)
	REAL CENTR
	COMMON  /LIMIT/LIMIT,ITEM,L,I,IX,ITEMX,ILIM /ALF/INP(72),ML 
	COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
	1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
	COMMON R2,JA,CENTR,J2,RJQ(20) /SIZ/RSZ,JCEN,KCEN
	1 /XRN/RN(3000) /DPY/ST(4000),MEDIT,IGO
	2 /YED/YED,IBOX,RBOX/JCLIP/JCLIP /FONT/JFONT
	EQUIVALENCE (R5,RJQ(3)),(R4,RJQ(2))
	2 ,(R3,RJQ(1)),(I2,INP(2)),(I1,INP(1))
	DATA RZMSZ/1.0/,RZMX/50.0/,RZMY/50.0/
C DATA STATEMENT NEEDED TO GET CORRECT NUMS. FOR ZU,ZD, ETC. BEFORE Z1, ETC.
C 'Z' = ZOOM   CAN'T DO ZOOM WHILE IN EDIT MODE
	IF(I2.NE.LDD.AND.I2.NE.LUU)CALL HYDPOG(2)
C CLEAR SPACING SCALE IF NOT MOVING UP OR DOWN.
	JA=24
	IGO=0
1180	IF(R2.LT.200.)GO TO 1190
	R3=AMOD(R2,100.)
	R2=(R2-R3)/100.
	R4=5*IFIX(9.0/R2)
C Z240 GIVES 2 40 20. Z366 GIVES 3 66 15.  Z490 GIVES 4 90 10.
1190	IF(R2.GT.1.0.OR.R3+R4.NE.0)GO TO 1195
	R3=50.0
	R4=50.0
C  Z1 ONLY ADDS IN 50,50   SO WE CAN ZOOM UP AND DOWN AT ANY SIZE.
1195	IF(I2.GT.0)GO TO 1250
C NEXT SECTION FOR ZLn, ZRn, ZUn, ZDn. n=% OF SCREEN CHANGE OF CENTER PO
	R3=R2
CRR*** ABOVE REPLACES REREAD
	IF(R3.EQ.0)R3=RZZZ
	RZZZ=R3
C SAVE R3 FOR REPEAT OF COMMAND WITHOUT n.
	R3=R3/RZMSZ
C 'ZR10' MEANS MOVE CENTER OF IMAGE 10% OF SCREEN SIZE TO RIGHT.
	IF(I2.NE.LRR)GO TO 1220
	R3=-R3
1200	R3=RZMX+R3
	R4=RZMY
1210	R2=RZMSZ
	GO TO 1290
1220	IF(I2.EQ.LEL)GO TO 1200
	IF(I2.NE.LUU)GO TO 1240
	R3=-R3
1230	R4=RZMY+R3
	R3=RZMX
	I1=0
C I1=0 STOPS REDRAWING OF SPACING SCALE FOR UP-DOWN ZOOMS
	GO TO 1210
1240	IF(I2.EQ.LDD)GO TO 1230

1250	JCLIP=525
C SETS CLIP LIMITS IN CLIP SUBR.
	IF(R2.NE.0)GO TO 1270
	IF(I2.EQ.LZZ)GO TO 1280
	IGO=-1
1260	R2=1.
C TO REDISPLAY WITH MAGNIFICATION - OR JUST RUN THROUGH DATA.
1270	IF(R2.LE.1)GO TO 1290
	JCLIP=511
	IF(R3.NE.0)GO TO 1290
1280	CALL ZCRSOR
C 'Zn' (AND NO OTHER NUM) WHERE n >1 ALLOWS YOU SET CENTER WITH LIGHTPEN
1290	RSZ=.845*R2
	RZMSZ=R2
	RZMX=R3
	RZMY=R4
C REMEMBER FACTORS
	JCEN=(R3*10.-500.)*RSZ
	KCEN=(R4*10.-480.)*RSZ
C  NEXT TO RECONSTITUTE SPACING SCALE.
CC1300	R2=(R4-100.)/100.
C%%%%%%%%%%%%%
CC	IF(R2.LT.0)R2=0
C  WE DON'T WORRY IF IT'S TOO HIGH (YET).
1310	R4=0
	R2=0
	IF(RZMSZ.LE.1)GO TO 1315
C PUT UP SPACING SCALE ABOVE STAFF 1 FOR ZOOMS .GT.1
C 2/81    	IF(RZMSZ.LT.2)R2=1.
C NO***** SETS HEIGHT OF SPACE NUMS. DEPENDING ON ZOOM FACTOR
	R2=1.
	IF(I1.NE.0)CALL SCL
	R2=0
1315	R3=0
	R4=0
C IF P5 ≠ 0 GOES THROUGH DATA IN OLD WAY.
	JFONT=0
	END

	SUBROUTINE ESPOS(RLINE)
C FOR 'ED' AND 'ES' COMMANDS
C** CALL BOX, EXCH
	COMMON /JCHAR/IXX,ISEMI,IBLA,IG,JED,KED,REDIT,RITEM 
	COMMON R2,JA,CENTR,J2,RJQ(20),J3,J4 /ALF/I1,I2
	COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
	1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
	EQUIVALENCE (R4,RJQ(2)),(R3,RJQ(1))
	IF(I2.NE.LSS)GO TO 1490
	CALL EXCH(R2,R3)
	J3=R3
C 'ES' IS "EDIT, STAFF, POS., CODE"
C 'ED' IS "EDIT, POS., STAFF, CODE"
1490	CALL BOX(-1,R2)
	IF(J4.EQ.0)KED=-1
	RITEM=R4
C  FOR 'ED POS., STF., CODE#'   (STF > 7 = ALL STAVES)
	IF(J3.GT.7)KED=-2
	RLINE=R2
	R2=R3
	END

	SUBROUTINE EDCEN(ICB)
	COMMON R2,JA /ALF/I1,I2,I3
	COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
	1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
	R2=1.
C CN=CENTER, CH=AT HEAD, CT=AT TAIL, CX=EXIT FROM CENTERING MODE.
	JA=13
	IF(I2.EQ.LXX)R2=0
	IF(I2.EQ.LHH)R2=-R2
	IF(I2.EQ.LTT)R2=-2.
	IF(I2.EQ.LBB)ICB=6
	IF(I2.EQ.LVV.OR.I2.EQ.LDD)ICB=-1
	IF(I3.EQ.LVV)ICB=ICB-10
C TYPE 'CB' FOR CENTER-BIG  (BIG RANGE =6) ***** 'CV'=SET CURVE OF SLUR
C CBV, CHV, CTV WILL SET CURVE AND DO CENTERING.  CD CENTERS DASH BETWEEN WDS.
	END

C  NEXT FOR CENTERING TEXT.  P10>1
	SUBROUTINE CENTXT(RD)
	COMMON /PTR/KWDS(1) /STF/RSTFAC(0/7),RSTJ2 /XRN/RN(1)
	COMMON R2,JA,CENTR,J2,RJQ(20)  /LIMIT/LIMIT,ITEM,L
	EQUIVALENCE (R10,RJQ(8)),(R3,RJQ(1))
	RB=0
	JX=KWDS(L+1)
1960	L=L+1
	K=KWDS(L)
	RB=RB+RN(K+9)
C  ADD SPACE NEEDED
	K=KWDS(L+1)
	IF(RN(K+1).NE.16.)GO TO 1970
	IF(RN(K).EQ.8.)GO TO 1960
C GO BACK IF MORE LETTERS TO COME
1970	R3=R10-(RB-3.4)*RD*RSTJ2/2.
C  +3.4 IS TO COMPENSATE FOR STARTING POS. BEING IN CENTER OF LET.
	R10=0
	IF(RN(JX).EQ.8)RN(JX+10)=0
	RN(JX+3)=R3
C THESE ARE NEEDED FOR ITEMS CENTERED DIRECTLY FROM 'WORDS'
	END

	SUBROUTINE CONTXT
C FOR TEXT CONTINUATION
	COMMON /PTR/KWDS(1) /STF/RSTFAC(0/7),RSTJ2 /XRN/RN(1)
	COMMON R2,JA,CENTR,J2,RJQ(20) /LIMIT/LIMIT,ITEM,L
	COMMON /RRJJ/RJJ2,RJJ(20),JJA
	EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(R5,RJQ(3))
1980	K=KWDS(L)
	R3=AMOD(RN(K+5),100.)*RSTJ2*RN(K+9)+RN(K+3)
C  AMOD BECAUSE P5+100 IS USED FOR PARTS PROGRAM.
	R4=RN(K+4)
	R5=RN(K+5)
	R2=RN(K+2)
	J2=R2
	L=KWDS(L+1)
	DO 1990 JJA=3,5
1990	RN(L+JJA)=RJQ(JJA-2)
	RN(L+2)=R2
	END

	SUBROUTINE MORCEN(ICB)
	IMPLICIT INTEGER(A-Q,S-Z)
	REAL STFF,CENTR
	COMMON  /STF/RSTFAC(0/7),RSTJ2
	COMMON  /RRJJ/RJJ2,RJJ(20),JJA
	COMMON  /LIMIT/LIMIT,ITEM,L,I,IX,ITEMX,ILIM
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
	1 (R6,RJQ(4)),(R4,RJQ(2)),(R7,RJQ(5)),(R3,RJQ(1)),
	4 (R11,RJQ(9)),(R8,RJQ(6)),(RJ3,RJJ(1)),(R13,RJQ(11))

2010	RJ3=R3
	JJA=JA
	IF(R8.NE.0)GO TO 2020
	IF(JA.EQ.1)R8=999.
C  999=0 FOR STEM EXTENSIONS.
C  USES ONLY 10 PARAMETERS BEYOND JA, J2
2020	CALL MSSLUP
	IF(JA.NE.6)GO TO 2040
2030	CALL HOMER

2040	IF(R13.EQ.0)RETURN
	RD=R11
	IF(ICB.EQ.0)GO TO 2050
C *** ICB = CENTER-BIG  I.E. BIG RANGE FOR CENTERING -- 6 UNITS. (CAN VAR
	X=ICB+10
	IF(ICB.LT.-1)ICB=X
C CBV  NOW=-4, CHV AND CTV =-10
	IF(RD.EQ.0)R11=ICB
	IF(JA.NE.4)GO TO 2045
	IF(ICB.GE.0)GO TO 2050
	CALL DASHES(ITEM,R2,RJQ)
C SUBR. DASHES WILL CENTER DASH BETWEEN TO WORDS OR SYLLABLES. (TYPE 'CD')
	GO TO 2060
2045	IF(JA.NE.5.OR.ICB.GT.0)GO TO 2050
C *** CV = SET CURVE OF SLUR. (FOR USE AFTER SPACE CHANGES, ETC.)
	R7=RCURVE(R3)
CC      R7=0.9+(R6-R3)/25.+ABS(R4-R5)/10.
C SAME FORMULA AS FOUND IN SLURZ ROUTINE.  FUNCTION CURVE IS IN LOOP
CC      IF(R7)RB=-RB
CC DONE IN 'RCURVE'***  R7=RB
	RJ7=R7
	IF(X.GT.0)GO TO 2060
	GO TO 2060
2050	CALL HOMER
2060	ICB=0
	R11=RD
C  R11 GETS CHANGED IN 'HOMER'
C RSTCEN IS FOR CENTERING WHOLE RESTS.
	IF(JA.EQ.10)R3=R3+RSTJ2
	IF(JA.NE.9)RETURN
	IF(J5.GT.3)RETURN
	CALL NOZERO(R6)
	R3=R3+RSTJ2+2.*RSTJ2*R6
C ABOVE HELPS CENTER NUMBERS UNDER NOTES(BECAUSE R3 IS AT CENTR OF NUM)
C  IF P13≠0 ANY ITEM WILL LINE UP WITH ANY OTHER ITEM. P13 IS RESET=0
C  P13=-1 POSITIONS ITEM ABOVE OR BELOW NOTE, =-2 JUST BEYOND STEM.
C CODE 10 (NUMBERS) SPACED TO LEFT AS WELL AS CODE 9, P5=1,2,3 (FLAT,SHR
	END

	SUBROUTINE GETMS(KG)
	IMPLICIT INTEGER(A-Q,S-Z)
	REAL STFF,CENTR
	DIMENSION LST(18),DP(0/7)
	COMMON /DL/X22,SAVER,NAME,EXT,IOLD
	COMMON  /LIMIT/LIMIT,ITEM,L,I,IX,ITEMX,ILIM
	1 /STF/RSTFAC(0/7),RSTJ2 /IDEV/IDEV,CHNG 
	2  /POSI/STFF(0/7),JJ2,IPOS  /ALF/INP(72)
	3 /SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	5 /PTR/PWDS(350) /MKX/MK1,MK2,LESS,IGT,MK(5),MINUS
	COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
	1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
	2 /JCHAR/IXX,ISEMI,IBLA,IG,JED,KED,REDIT,RITEM 
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	1 /XRN/RN(3000) /DPY/ST(4000),MEDIT,IGO  /DPTR/WDS(350)
	EQUIVALENCE (J3,JQ(1)),(I2,INP(2)),(I1,INP(1))
	1,(R4,RJQ(2)),(R5,RJQ(3)),(R8,RJQ(6))
	DATA PLUS/'+'/,ITMP/'TMP'/,MS/'MS'/,IZERO/'0'/,N99/'99'/

C  TO GET DISPLAY: 'G'; 'GM'  ADDS TO DPY;
	IF(KG.NE.0)GO TO 2250
2220	J2=0
	IF(I.EQ.1)GO TO 2230
	L=NAME
	X=EXT
CC	IF(I2.EQ.IBLA)GO TO 2110
	IF(I2.NE.IBLA)GO TO 1
	KG=1
	RETURN
1	J2=-1
	I2=(I2-IZERO)/536870912
C TURN ASCII INTO INTEGER.
	IF(I2.GT.9.OR.I2.LT.0)GO TO 2230
C VERT. STEPS PER INCH = 23.9 (CONSIDER STAFF SIZE FACTOR TOO)
	R2=I2
	J2=1
C  'GM'=GET MORE(BUT OLD OUTPUT NAME IS RESTORED AT 2207)
C 'Gn'=GET MORE AND PUT IT ON STAFF n AT POS. OF STAFF 0'S P8.
C ANYTHING AFTER 'G' BUT A NUMBER IS TAKEN AS 'GM'.
2230	I1=-1
	CALL NAMEXT(INP,NAME,EXT)
C  NOW TYPE 'G NAME' OR 'GM NAME'
	IF(NAME.NE.IBLA)GO TO 2250
2240	IF(K.NE.PLUS)GO TO 2245
C NOW NEXT-TO-LAST LETTER IS MOVED UP, LAST LETTER IS RESET TO 'A'
	NAME=((NAMZ+J3).AND."777777777400).OR."202
C   .AND.ETC ZEROS LAST 8 BITS, .OR."202 PUTS IN 'A'
	NAMZ=NAME
	K=0
	GO TO 2265
240	KG=4
700	FORMAT(72A1)
	RETURN
2245	CALL TYPSTR(' NAME.EXT?  ')
	READ(IDEV,700,END=240)INP
C GO PUT A1'S INTO A5, ETC.
	CALL NAMEXT(INP,NAME,EXT)
	IF(NAME.EQ.IBLA)GO TO 2270
	IF(NAME.NE.N99)GO TO 2250
C TYPE '99' TO BACK OUT OF 'SAVE'.
	NAME=L
	EXT=X
130	KG=2
	RETURN
2250	IF(I1.NE.LESS)GO TO 2260
	IDEV=5
	GO TO 2240
2260	CALL LO2UP(NAME)
	CALL LO2UP(EXT)
	K=NAME
	JA=2
	J3=256
	IF(K.NE.MINUS)GO TO 2263
	K=PLUS
	JA=-JA
	J3=-J3
2263	IF(K.EQ.PLUS)NAME=NAMZ+JA
C NAME='+' WHEN "NX" HAS BEEN TYPED. (UPS LAST LETTER OF FIVE TO NEXT)
2265	IF(LOOKX(NAME,EXT).EQ.0)GO TO 2240
C  FUNC. LOOKD IS 'FAIL' PROG. TO CHECK ON LOOKUPS
2270	JA=-1
C  -1 IS FOR 8852+3
2280	J=ITEM+1
	IF(NAME.NE.IBLA)GO TO 2290
C***	CALL GETEXT('TMP','MS ')
C****	CALL INMUS('TMP','MS',RN(I),PWDS(J),RSTFAC)
	K=ITMP
	JJ2=MS
	GO TO 2300
C***2290	CALL GETEXT(NAME,EXT)
C**** 2290	CALL INMUS(NAME,EXT,RN(I),PWDS(J),RSTFAC)
2290	K=NAME
	JJ2=EXT
2300	CALL INMUS(K,JJ2,RN(I),PWDS(J),RSTFAC)
    	IF(J2.EQ.0)GO TO 2310
	NAME=L
	EXT=X
C ABOVE GETS BACK ORIGINAL NAME WITH 'GM' AND 'Gn'
2310	RSTF=0
	NAMZ=NAME
C  SAVE THE NAME FOR NX OR '+' ROUTINE (GOES UP THE ALPHABET)
C***	CALL EXTIN(RSTFAC,128)
C***	CALL EXTIN(PWDS(J),JJ2)
C***	CALL EXTIN(RN(I),IPOS)
	ITEM=ITEM+JJ2-2
	IF(J2)2350,2320,2330
CC      IF(I2.EQ.IM)GO TO 2203
C J2=-1,1=GM *******'GET MORE' DOES NOT GET MOTIVE LIST OF NEW FILE.****
2320	IF(LCNT.GT.1)CALL EXTIN(LIST,LCNT)
	I=IPOS
	IF(RSTF.EQ.0)GO TO 1320
C  (END OF V ARRAY)RSTF=-1 MEANS READ THE DPY BUFFER
	CALL EXTIN(ST,4302)
	CALL DPYNEW
	GO TO 130

2330	DO 2340 K=1,ITEM
	IF(RN(PWDS(K)+1).NE.8)GO TO 2340
	J3=PWDS(K)
	IF(RN(J3+2).NE.0)GO TO 2340
	R8=RN(J3+8)
C ASSUMES SPACE INFO IS IN P8.  GET IT.
C NEXT FOR VERTICAL SPACING OF NEW STAFF TO BE READ.
	R5=23.9/RSTFAC(0)
	R3=.73*R2
C INCHES BETWEEN STAVES=.73
	R4=(R8-R3)*R5
C R4=CHANGE FROM NORMAL POSITION FOR INCOMING STAFF.
	GO TO 2350
2340	CONTINUE
C IF NO STAFF 0 WAS FOUND R4=0
	R4=0
2350	M=I-1
	DO 2360 K=J,J+JJ2-2
	PWDS(K)=PWDS(K)+M
	IF(J2.LE.0)GO TO 2360
C NEXT FOR GET-MORE AND PUT ON STAFF #R2
	J3=PWDS(K)
	RN(J3+2)=R2
	IF(RN(J3+1).NE.8)GO TO 2360
	RN(J3+4)=R4
C SET HEIGHT OF STAFF - DEPENDANT UPON P8 OF STAFF 0.
CCC     IF(RN(J3).GE.6)RN(J3+8)=0
C ZERO SPACING PARAM IN UPPER STAVES.
2360	CONTINUE
1320	KG=3
	END